Gigarom 1/Gigarom Macintosh Archives (Quantum Leap)(CDRM1080320)(1993).iso/FILES/HYP/C-D/DartmouthXCMDs.cpt/Dartmouth XCMDs Vol 1&2/card_3697.txt

Text File | 1989-02-26 | 10KB | 351 lines

-- card: 3697 from stack: in
-- bmap block id: 0
-- flags: 0000
-- background id: 3241
-- name:


-- part 1 (button)
-- low flags: 00
-- high flags: A003
-- rect: left=75 top=300 right=322 bottom=192
-- title width / last selected line: 0
-- icon id / first selected line: 0 / 0
-- text alignment: 1
-- font id: 0
-- text size: 12
-- style flags: 0
-- line height: 16
-- part name: ClipToPICT
----- HyperTalk script -----
on mouseUp
  put ClipToPICT(0,"Different Color")
end mouseUp



-- part 2 (field)
-- low flags: 80
-- high flags: 2007
-- rect: left=12 top=26 right=298 bottom=491
-- title width / last selected line: 0
-- icon id / first selected line: 0 / 0
-- text alignment: 0
-- font id: 22
-- text size: 10
-- style flags: 0
-- line height: 13
-- part name: Source


-- part 3 (button)
-- low flags: 00
-- high flags: A003
-- rect: left=314 top=300 right=322 bottom=435
-- title width / last selected line: 0
-- icon id / first selected line: 0 / 0
-- text alignment: 1
-- font id: 0
-- text size: 12
-- style flags: 0
-- line height: 16
-- part name: Show LSP Source
----- HyperTalk script -----
on mouseUp
  set the visible of card field 1 to not the visible of card field 1
  if the visible of card field 1 is true then
    set the name of me to "Hide LSP Source"
  else set the name of me to "Show LSP Source"
end mouseUp



-- part contents for background part 16
----- text -----
CLIPTOPICT XFCN version 1.0
Kevin Calhoun

ClipToPICT creates a PICT resource from a picture you've copied to the clipboard and copies it to the current stack.  You can tell ClipToPICT what ID number you want the PICT resource to have, or you can let it select an unused number for you.  If you choose a number that belongs to another PICT resource currently contained in your stack, the new picture will overwrite the old one.

You'll know when there's a picture on the clipboard by examing HyperCard's edit menu.  If the paste item says "Paste Picture," then there's a picture available for ClipToPICT to turn into a PICT resource.

INVOKING CLIPTOPICT

get ClipToPICT(pictID,pictName)

result:  resourceID

You must pass a number in the pictID parameter.  If you pass 0, ClipToPICT will find an unused ID number to assign the new PICT resource and, if it is copied successfully, return that ID.  If you pass any other number, ClipToPICT will use that number as the ID of the new PICT resource, replacing any old PICT resource in the current stack with the same ID, and, if it is copied successfully, return the same number.

You don't have to name the new PICT resource--the pictName parameter is optional.    If you specify a name that already belongs to a PICT resource in the current stack, ClipToPICT will replace the old resource with the new one.

If the clipboard contains no pictures, or if there was a problem accessing the scrap, opening the current stack's resource file, or writing the resource, Install Picture will return an error message.  Word 1 of this message will be "Error."

EXAMPLES

put ClipToPICT(0,"The Little Engine That Could") into pictNumber
get ClipToPICT(2880,"")

REVISION HISTORY
1.0 -- 4/22/88

-- part contents for card part 2
----- text -----
UNIT InstallPicture;
{ ClipToPICT XFCN ©1988 by the Trustees of Dartmouth College. }
{ Written by John K. Calhoun, Courseware Development. }

INTERFACE
 USES
  XCMDIntf, ROM85;
 TYPE
  Str31 = STRING[31];

 PROCEDURE Main (paramPtr : XCMDPtr);


IMPLEMENTATION

 PROCEDURE DoJsr (addr : ProcPtr);
 INLINE
  $205F, $4E90;

 FUNCTION EvalExpr (paramPtr : XCmdPtr;
         expr : Str255) : Handle;
 BEGIN
  WITH paramPtr^ DO
   BEGIN
    inArgs[1] := ORD(@expr);
    request := xreqEvalExpr;
    DoJsr(entryPoint);
    EvalExpr := Handle(outArgs[1]);
   END;
 END;

 FUNCTION StringLength (paramPtr : XCmdPtr;
         strPtr : Ptr) : LongInt;
 BEGIN
  WITH paramPtr^ DO
   BEGIN
    inArgs[1] := ORD(strPtr);
    request := xreqStringLength;
    DoJsr(entryPoint);
    StringLength := outArgs[1];
   END;
 END;

 FUNCTION NumToStr (paramPtr : XCmdPtr;
         num : LongInt) : Str31;
  VAR
   str : Str31;
 BEGIN
  WITH paramPtr^ DO
   BEGIN
    inArgs[1] := num;
    inArgs[2] := ORD(@str);
    request := xreqNumToStr;
    DoJsr(entryPoint);
    NumToStr := str;
   END;
 END;

 PROCEDURE ZeroToPas (paramPtr : XCmdPtr;
         zeroStr : Ptr;
         VAR pasStr : Str255);
 BEGIN
  WITH paramPtr^ DO
   BEGIN
    inArgs[1] := ORD(zeroStr);
    inArgs[2] := ORD(@pasStr);
    request := xreqZeroToPas;
    DoJsr(entryPoint);
   END;
 END;

 FUNCTION PasToZero (paramPtr : XCmdPtr;
         str : Str255) : Handle;
 BEGIN
  WITH paramPtr^ DO
   BEGIN
    inArgs[1] := ORD(@str);
    request := xreqPasToZero;
    DoJsr(entryPoint);
    PasToZero := Handle(outArgs[1]);
   END;
 END;

 FUNCTION StrToNum (paramPtr : XCmdPtr;
         str : Str31) : LongInt;
 BEGIN
  WITH paramPtr^ DO
   BEGIN
    inArgs[1] := ORD(@str);
    request := xreqStrToNum;
    DoJsr(entryPoint);
    StrToNum := outArgs[1];
   END;
 END;

 FUNCTION GetTheNameOfThisStack (paramPtr : XCMDPtr) : Str255;
  VAR
   str1, str2 : str255;
   theResult : Handle;
   theLength : INTEGER;
 BEGIN
  str1 := 'word 2 of the long name of this stack';
  theResult := EvalExpr(paramPtr, str1);
  IF theResult <> NIL THEN
   BEGIN
    theLength := StringLength(paramPtr, theResult^);
    DisposHandle(theResult);

    str2 := NumToStr(paramPtr, theLength - 1);
    theResult := EvalExpr(paramPtr, CONCAT('char 2 to ', str2, ' of ', str1));
    IF theResult <> NIL THEN
     BEGIN
      ZeroToPas(paramPtr, theResult^, str1);
      DisposHandle(theResult);
     END
    ELSE
     str1 := '';
   END
  ELSE
   str1 := '';
  GetTheNameOfThisStack := str1;
 END;

 PROCEDURE GetPictScrap (paramPtr : XCMDPtr);
  VAR
   parameterCount : INTEGER;
   id : INTEGER;
   name : Str255;
   scrapLength : longint;
   offset : longint;
   thePicHandle : Handle;
   str : Str255;
   myStack : INTEGER;
   resAlready : Handle;

  PROCEDURE passReturnValue (theMsg : Str255); { set theResult and quit }
  BEGIN
   paramPtr^.returnValue := PasToZero(paramPtr, theMsg);
  END;

  PROCEDURE GetParameters;
  BEGIN
   parameterCount := paramPtr^.paramCount;
   IF parameterCount > 0 THEN
    BEGIN
     ZeroToPas(paramPtr, paramPtr^.params[1]^, str);
     id := StrToNum(paramPtr, str);
     IF parameterCount > 1 THEN
      ZeroToPas(paramPtr, paramPtr^.params[2]^, name)
     ELSE
      name := '';
    END;
  END;

  PROCEDURE CheckForSameTypeIDName;
{ Remove all PICT resources of the same ID and the same name as }
{ the one we're going to copy. Why?  Because... }
{ "When you add a resource to a file, the Resource Manager doesn't check }
{ to see if the file already has a resource with the type and ID you're }
{ trying to add...  ...future GetResource calls will never return the new }
{ resource that you just added, since the one that was there previously }
{ comes before the new one in the resource file's map...  This means that }
{ the new resource you just added is impossible to access." }
{    --Scott Knaster, How To Write Macintosh Software, p. 329 }
{      Hayden Book Company, Hasbrouck Heights, NJ, 1986. }
  BEGIN
   IF id = 0 THEN
    REPEAT
     id := Unique1ID('PICT');
    UNTIL id > 127
   ELSE
    BEGIN
     REPEAT
      resAlready := Get1Resource('PICT', id);
      IF resAlready <> NIL THEN
       BEGIN
        RmveResource(resAlready);
        DisposHandle(resAlready);
       END;
     UNTIL resAlready = NIL;

     IF name <> '' THEN
      BEGIN
       REPEAT
        resAlready := Get1NamedResource('PICT', name);
        IF resAlready <> NIL THEN
         BEGIN
          RmveResource(resAlready);
          DisposHandle(resAlready);
         END;
       UNTIL resAlready = NIL;
      END;
    END;
  END;

 BEGIN
  GetParameters;
  IF parameterCount > 0 THEN
   BEGIN
    str := GetTheNameOfThisStack(paramPtr);
    IF str <> '' THEN
     BEGIN
      myStack := OpenResFile(str);
      IF (myStack = -1) AND (ResError = eofErr) THEN
       BEGIN
        CreateResFile(str);
        IF ResError = noErr THEN
         myStack := OpenResFile(str);
       END;
      IF myStack > -1 THEN
       BEGIN
        scrapLength := GetScrap(NIL, 'PICT', offset);
        IF scrapLength >= 0 THEN
         BEGIN
          thePicHandle := NewHandle(0);
          IF thePicHandle <> NIL THEN
           BEGIN
            scrapLength := GetScrap(thePicHandle, 'PICT', offset);
            IF scrapLength > 0 THEN
             BEGIN
              HNoPurge(Handle(thePicHandle));
              UseResFile(myStack);
              CheckForSameTypeIDName;
              AddResource(thePicHandle, 'PICT', id, name);
              IF ResError = noErr THEN
               BEGIN
                SetResAttrs(thePicHandle, resPurgeable + resChanged);
                WriteResource(thePicHandle);
               END;
              UpdateResFile(myStack);
              HPurge(Handle(thePicHandle));
              passReturnValue(NumToStr(paramPtr, id));
             END  { if we read the scrap successfully }
            ELSE
             passReturnValue(CONCAT('Error ', NumToStr(paramPtr, scrapLength)));
           END  { if thePicHandle <> nil }
          ELSE
           passReturnValue(CONCAT('Error ', NumToStr(paramPtr, MemError)));
         END  { if there is scrap of type PICT }
        ELSE
         passReturnValue(CONCAT('Error ', NumToStr(paramPtr, scrapLength), ' (no pictures on clipboard)'));
       END  { if we opened resource fork successfully }
      ELSE
       passReturnValue(CONCAT('Error ', NumToStr(paramPtr, ResError)));
     END
    ELSE
     passReturnValue('Error (can''t get stack name)');
   END
  ELSE
   passReturnValue('ClipToPICT XCMD 1.0 -- April 22, 1988');
 END;

 PROCEDURE Main;
 BEGIN
  GetPictScrap(paramPtr);
 END;

END.